{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.Alpha
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Alpha renaming for K Normal Form.
--
--------------------------------------------------------------------------------

module WumpusExpr.Alpha
  (
    
    alpha

  ) where


import WumpusExpr.FreshMon
import WumpusExpr.KNormal
import WumpusExpr.VarId

import Control.Applicative
import qualified Data.Map as M
import Data.Monoid

--------------------------------------------------------------------------------
-- alpha renaming

type Env = M.Map VarId VarId

find :: Env -> VarId -> VarId
find env x = maybe x id $ M.lookup x env

findVal :: Env -> Value -> Value
findVal env (Var v) = Var $ find env v
findVal _   v       = v

-- inserts :: [(VarId,VarId)] -> Env -> Env
-- inserts vvs env = foldr (\(a,b) acc -> M.insert a b acc) env vvs


-- Note - alpha renaming should be done in the context of 
-- Programs not expressions...


collectFunNames :: Program -> [VarId]
collectFunNames (Program _ defs) = map fun_name defs

alpha :: Program -> Mon Program
alpha p1@(Program main_proc defs) = 
    Program <$> alphaF env main_proc <*> mapM (alphaF env) defs
  where
    names = collectFunNames p1
    env   = M.fromList $ zip names names 


-- Maybe args should be alpha renamed?
--
alphaF :: Env -> Fundef -> Mon Fundef
alphaF env (Fundef hd args body) = Fundef hd args <$> ac env1 body
  where
    env1 = env `mappend` (M.fromList $ zip args args)


ac :: Env -> Expr -> Mon Expr
ac env (Val val)            = Val <$> acV env val

-- Don\'t alpha rename opcodes.
-- ac env (Prim v vs)              = return $ Prim v $ map (findVal env) vs

ac env (FunCall v vs)           = return $ FunCall v $ map (findVal env) vs

ac env (Let vid e1 e2)          = do
    x  <- fresh (varType vid)
    ea <- ac env e1
    eb <- ac (M.insert vid x env) e2
    return $ Let x ea eb

ac env (Ifte v1 e1 e2)         = 
    Ifte (findVal env v1) <$> ac env e1 <*> ac env e2

ac env (Cmd cmd)                = Cmd <$> acC env cmd
ac env (e1 :>> e2)              = (:>>) <$> ac env e1 <*> ac env e2
ac env (Return e)               = Return <$> ac env e


acV :: Env -> Value -> Mon Value
acV env (Var vid)       = return $ Var $ find env vid
acV env (UnaryV op v)   = return $ UnaryV op (findVal env v)
acV env (BinV op v1 v2) = return $ BinV op (findVal env v1) (findVal env v2)
acV env (RelV op v1 v2) = return $ RelV op (findVal env v1) (findVal env v2)
acV _   val             = return val


acC :: Env -> Command -> Mon Command
acC _   (NewPath)                   = pure NewPath
acC _   (ClosePath)                 = pure ClosePath
acC _   (Fill)                      = pure Fill
acC _   (Stroke)                    = pure Stroke
acC env (MoveTo x y)                = 
    pure $ MoveTo (findVal env x) (findVal env y)

acC env (LineTo x y)                = 
    pure $ LineTo (findVal env x) (findVal env y)

acC env (CurveTo x1 y1 x2 y2 x3 y3) = 
    pure $ CurveTo (findVal env x1) (findVal env y1)
                   (findVal env x2) (findVal env y2)
                   (findVal env x3) (findVal env y3)

acC _   (GSave)                     = pure GSave
acC _   (GRestore)                  = pure GRestore
acC env (Scale x y)                 = 
    pure $ Scale (findVal env x) (findVal env y)

acC env (Rotate ang)                = pure $ Rotate (findVal env ang)

acC env (Translate x y)             =
    pure $ Translate (findVal env x) (findVal env y)

acC env (Transform a b c d e f)     =    
    pure $ Transform (findVal env a) (findVal env b)
                     (findVal env c) (findVal env d)
                     (findVal env e) (findVal env f)

acC env (ShowText v)                = pure $ ShowText (findVal env v)
 
